Celestin Apprentice 4

home *** CD-ROM | disk | FTP | other *** search

/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Mops 2.7 / Mops source / System source / String+ < prev next >

Wrap

Text File | 1995-07-19 | 13.5 KB | 601 lines | [TEXT/MSET]

\ STRING+ class. This adds many useful methods to class String. :class STRING+ super{ string } \ ====== Utility methods ====== :m SWAPPOS: \ Swaps POS with the top of the stack. get: pos swap put: pos ;m :m SAVE: \ ( -- hnd pos lim ) Saves the string+ object on the stack. handle: self pos: self lim: self ;m :m RESTORE: \ ( hnd pos lim -- ) Just what you'd expect. >lim: self >pos: self ^base ! ;m :mcode 2ND: \ ( -- c ) loc \ Returns the 2nd char in the active part, or 0 if none. MOVEQ #0,D1 BSR dic[getit] BNE.S ok JMP dic[$fail] ok SUBQ #1,D0 BLE.S end MOVE.B 1(A0),D1 end MOVE D1,-(SP) ;mcode :mcode LAST: \ ( -- c ) loc \ Returns the last char in the active part. MOVEQ #0,D1 BSR dic[getit] BNE.S ok JMP dic[$fail] ok MOVE dic[$start],A1 ; A1 -> start of string ADD 12(A2),A1 ; Add LIM, giving end of active part MOVE.B -1(A1),D1 ; Pick up last char MOVE D1,-(SP) ;mcode \ =========== Comparison: =========== :m COMPARE: \ ( addr len -- n ) Compares the string ( addr len ) \ with the active part of SELF. Comparison is \ by CMPSTR, with the ( addr len ) string as the first \ operand. n is the return result as described above \ for CMPSTR. get: self cmpstr ;m :m ?: { addr len -- n } \ As for COMPARE:, except that if the ( addr len ) string \ is shorter than the active part of SELF, only len chars \ from the current position of SELF are used. This only \ makes a difference if an "equal" result is obtained. addr len get: self len min cmpstr ;m :m =?: { addr len -- f } \ A compare for equal/not equal only. \ Returns true on equal. addr len get: self len min cmpstr 0= ;m :mcode CH=?: \ ( c -- f ) \ Compares the given single character against the \ character at POS. Returns true on equal. \ If the active part of the string is empty, \ always returns false. loc MOVE (SP),D1 CLR (SP) BSR dic[getit] BEQ.S end TST dic[case?] BEQ.S nocase CMP.B (A0),D1 BNE.S end BRA.S yes nocase LEA 8(dic[UCtbl]),A1 MOVE.B 0(A1,D1.W),D0 MOVE.B (A0),D1 CMP.B 0(A1,D1.W),D0 BNE.S end yes MOVE #-1,(SP) end ;mcode \ ============= Searching ============== \ SEARCH: and <SEARCH: search for the passed-in string. They return a boolean \ indicating if found. :mcode SEARCH: \ ( addr len -- b ) loc BSR dic[getit] MOVE D4,-(A7) ; Save D4 on return stk POP D4 ; D4 = len MOVE (SP),A1 ; A1 = addr - search string CLR (SP) ; For return result MOVEQ #0,D1 MOVE.B (A1)+,D1 ; D1 = 1st char of search string SUBQ #1,D4 ; D4 = length of rest of sch str SUB D4,D0 BLE.S end ; Out with False if self not long ; enough loop BSR dic[csch] BNE.S end MOVEM D0/D1/A0/A1,-(SP) ; Save regs across ccmp call MOVE D4,D0 BSR dic[ccmp] MOVEM (SP)+,D0/D1/A0/A1 BNE.S loop SUBQ #1,(SP) ; Found SUBQ #1,A0 SUB dic[$start],A0 MOVE A0,12(A2) ; Set LIM to found position end MOVE (A7)+,D4 ; Restore D4 ;mcode :mcode <SEARCH: \ ( addr len -- b ) loc BSR dic[getit] MOVE D4,-(A7) ; Save D4 on return stk POP D4 ; D4 = len MOVE (SP),A1 ; A1 = addr CLR (SP) ; For return result MOVEQ #0,D1 MOVE.B (A1)+,D1 ; D1 = 1st char of search string SUBQ #1,D4 ; D4 = length of rest of sch str SUB D4,D0 ; Reduce search length by this amount BLE.S end ; Out with False if self not long enough MOVE D0,D2 ; OK, but need to adjust D2 as well SWAP D2 ADD D0,A0 loop BSR dic[<csch] BNE.S end MOVEM D0/D1/A0/A1,-(SP) ; Save regs across ccmp call MOVE D4,D0 ADDQ #1,A0 BSR dic[ccmp] MOVEM (SP)+,D0/D1/A0/A1 BNE.S loop SUBQ #1,(SP) ; Found SUB dic[$start],A0 MOVE A0,8(A2) end MOVE (A7)+,D4 ; Restore D4 ;mcode :m SCH&SKIP: { addr len \ savelim -- b } \ Searches for the string ( addr len ) \ and if found, sets POS to the character following the \ found substring. Leaves LIM unchanged. get: lim -> savelim addr len search: self dup 0EXIT step: self len skip: self savelim put: lim ;m \ CHSEARCH: and <CHSEARCH: search for a single character. :mcode CHSEARCH: \ ( c -- b ) loc MOVE (SP),D1 ; D1 = char CLR (SP) ; for return result BSR dic[getit] BLE.S end BSR dic[csch] BNE.S end SUBQ #1,(SP) ; Set result to "true" SUBQ #1,A0 SUB dic[$start],A0 MOVE A0,12(A2) end ;mcode :mcode <CHSEARCH: \ ( c -- b ) loc MOVE (SP),D1 CLR (SP) BSR dic[getit] BLE.S end ADD D0,A0 BSR dic[<csch] BNE.S end SUBQ #1,(SP) SUB dic[$start],A0 MOVE A0,8(A2) end ;mcode :m CHSCH&SKIP: { c \ savelim -- b } get: lim -> savelim c chsearch: self dup 0EXIT step: self 1 skip: self savelim put: lim ;m \ CHSKIP?: ( c -- b ) searches for the first character NOT equal to c. \ This method has a couple of differences to the other searching methods, \ dictated by what we normally need it for. If it suceeds, POS (not LIM) is \ set to that position, and it is always case sensitive, regardless of CASE?. :mcode CHSKIP?: loc MOVE (SP),D1 ; D1 = char CLR (SP) BSR dic[getit] BLE.S end CMP.B D0,D0 ; Set "equal" BRA.S lptst loop CMP.B (A0)+,D1 lptst DBNE D0,loop DBNE D2,loop BEQ.S end SUBQ #1,A0 SUB dic[$start],A0 MOVE A0,8(A2) SUBQ #1,(SP) end ;mcode :m CHSKIP: \ ( c -- ) As for CHSKIP?:, but returns no result. chskip?: self drop ;m \ SCAN: and <SCAN: search for a single character, using a translate table. \ "Success" is defined as a character which yields a non-zero value from \ the table. The return result is this non-zero value, or zero if none \ was found. :mcode SCAN: \ ( trtbl -- n ) loc scan MOVEQ #0,D1 ; For result BSR dic[getit] BLE.S end MOVE (SP),A1 TST.B scaxq BEQ.S lptst ; Note: for both SCAN: and SCAX: we enter BRA.S lptstx ; the loop with the CC not satisfying the ; test condition. Important!! scaxq dc.w 0 ; Set nonzero if this is a scax loop MOVE.B (A0)+,D1 MOVE.B 2(A1,D1.W),D1 lptst DBNE D0,loop DBNE D2,loop BEQ.S end ; If not found BRA.S found loopx MOVE.B (A0)+,D1 MOVE.B 2(A1,D1.W),D1 lptstx DBEQ D0,loopx DBEQ D2,loopx BNE.S end ; If not found found SUBQ #1,A0 SUB dic[$start],A0 MOVE A0,12(A2) end MOVE D1,(SP) CLR.B scaxq ;mcode :mcode <SCAN: \ ( trtbl -- n ) bscan MOVEQ #0,D1 ; For result BSR dic[getit] BLE.S bend MOVE (SP),A1 ADD D0,A0 TST.B scaxq BEQ.S blptst BRA.S blptstx bloop MOVE.B -(A0),D1 MOVE.B 2(A1,D1.W),D1 blptst DBNE D0,bloop DBNE D2,bloop BRA.S bfix bloopx MOVE.B -(A0),D1 MOVE.B 2(A1,D1.W),D1 blptstx DBEQ D0,bloopx DBEQ D2,bloopx bfix SUB dic[$start],A0 MOVE A0,8(A2) bend MOVE D1,(SP) CLR.B scaxq ;mcode \ SCAX: and <SCAX: - "Scan excluding". As for scan:, but "success" is \ defined as a character which yields a zero value from the table. \ The return result is the last byte fetched from the table, which \ will be zero on success, or otherwise it will be whatever table byte \ corresponds to the last char in the active part of the string - \ something non-zero, in any case. :mcode SCAX: SUBQ.B #1,scaxq BRA scan ;mcode :mcode <SCAX: SUBQ.B #1,scaxq BRA bscan ;mcode :mcode TRANSLATE: \ ( trtbl -- ) loc POP A1 BSR dic[getit] BLE.S end MOVEQ #0,D1 BRA.S lptst loop MOVE.B (A0),D1 MOVE.B 2(A1,D1.W),(A0)+ lptst DBRA D0,loop DBRA D2,loop end ;mcode :mcode TRANS1ST: \ ( trtbl -- n ) loc MOVEQ #0,D1 BSR dic[getit] BLE.S end MOVE (SP),A1 MOVE.B (A0),D1 MOVE.B 2(A1,D1.W),D1 end MOVE D1,(SP) ;mcode :m >UC: \ Faster than UPPER, and not limited to 64K. UCtbl translate: self ;m :m CH>UC: \ Converts the first char of SELF to upper case. UCtbl trans1st: self ^1st: self c! ;m \ ========= Insertion, deletion, replacement ========== :m CHINSERT: \ ( c -- ) Inserts the given character. pad c! pad 1 insert: super ;m :m OVWR: { addr len -- } \ Overwrites the active part of SELF with the string ( addr len ). \ Copying stops at the end of the active part, or when len characters \ have been transferred. POS is incremented by the number of chars \ transferred. This operation is faster than normal replacement, as the \ length of SELF cannot change, so Munger is not called. addr get: self len min dup -> len cmove len +: pos ;m :m CHOVWR: \ ( c -- ) Overwrites the first char of the active \ part of the string ( if any ) by the char c. get: self IF c! 1 skip: self else 2drop THEN ;m :m $OVWR: \ ( str -- ) get: string+ ovwr: self ;m private :m (REPL): { len1 addr2 len2 -- } 0 len1 addr2 len2 munger: self put: pos ;m public :m REPL: { addr len -- } len: self addr len (repl): self get: pos put: lim ;m :m $REPL: { str \ state -- } str getState: string -> state str lock: string str get: string repl: self state str setState: string ;m :m SCH&REPL: { addr1 len1 addr2 len2 -- b } addr1 len1 search: self dup 0EXIT step: self len1 addr2 len2 (repl): self get: pos put: lim ;m :m REPLALL: { addr1 len1 addr2 len2 -- } \ Replaces all occurrences of (addr1 len1) by (addr2 len2) \ in the WHOLE of self. Self is left reset. reset: self BEGIN addr1 len1 search: self WHILE step: self len1 addr2 len2 (repl): self nolim: self REPEAT clear: pos ;m :m DELETE: \ Deletes the active part of the string. \ LIM is then set equal to POS. 0 0 repl: self ;m :m DELETEN: { n -- } \ From POS, deletes n characters or up to LIM, \ whichever comes first. LIM is reduced by the number \ of characters deleted. len: self n min dup -> n 0 0 (repl): self n negate +: lim ;m \ ========= Line-oriented methods: ========= \ LINE>: sets LIM to the end of the current line (i.e. the next Return \ character, or the end of the string). POS isn't moved -- it need not \ be at the start of the line. :mcode LINE>: loc MOVE 4(A2),12(A2) ; nolim: self BSR dic[getit] BLE.S end SUBQ #1,D0 loop CMPI.B #13,(A0)+ DBEQ D0,loop BNE.S end SUBQ #1,A0 SUB dic[$start],A0 MOVE A0,12(A2) end ;mcode \ NEXTLINE?: sets POS and LIM to delimit the next line. This means POS \ will point to the Return character, and LIM to the char preceding the \ next Return, or the end of the string. If LIM initially does not point \ to a Return character, the "next" line will actually be the rest of the \ current one, starting from where LIM pointed. This behaviour means that \ if POS and LIM are initially zero, calling NEXTLINE?: will actually \ yield the first line. This can be useful. :mcode NEXTLINE?: \ ( -- f ) loc CLR -(SP) MOVE (A2),A0 MOVE (A0),A0 MOVE 4(A2),D0 MOVE 12(A2),D1 MOVE D1,8(A2) MOVE D0,12(A2) SUB D1,D0 BLE.S end SUBQ #1,(SP) ; We'll get some kind of line! MOVE A0,A1 ADD D1,A0 CMPI.B #13,(A0)+ BNE.S ready ADDQ #1,8(A2) ready SUBQ #1,D0 BEQ.S setlim SUBQ #1,D0 move d0,d2 swap d2 loop CMPI.B #13,(A0)+ DBEQ D0,loop dbeq d2,loop BNE.S setlim SUBQ #1,A0 setlim SUB A1,A0 MOVE A0,12(A2) end ;mcode \ The reverse operation is a bit easier because we don't need to check \ if POS is initially pointing at a Return. :m <NEXTLINE?: <step: self len: self NIF false EXIT THEN RET <chsearch: self drop true ;m :m ADDLINE: \ ( addr len -- ) add: self get: size if ^1st: self 1- c@ RET = else false then ?exit RET +: self ;m :m $ADDLINE: { str \ state -- } str getState: string -> state str lock: string str get: string addline: self state str setState: string ;m \ =========== I/O operations: ============ :m READN: { fcb n \ state -- } \ Reads n bytes from the given file \ into SELF, completely replacing whatever was there before. \ The read stops when end file is reached. n setsize: self getState: self -> state lock: self all: self fcb read: file state setState: self dup -39 = IF drop 0 THEN OK? \ We don't worry if the error \ was endfile bytesRead: [ fcb ] setSize: self ;m :m READLINE?: { fcb n \ state -- b } \ Reads the next line up to a max of n chars. \ Returns false if end of file. Does not \ include the final Return char. n setsize: self getState: self -> state lock: self all: self fcb readline: file state setState: self dup NIF \ Success. Assume we got a Return drop fcb bytesRead: file 1- setSize: self true exit THEN dup EOF = IF \ Return True if we got any bytes at all drop fcb bytesRead: file dup setSize: self 0<> exit THEN ( File error - cause error handler to execute ) OK? ;m :m READREST: { fcb -- } \ Reads all the remainder of the given file into SELF. fcb fcb size: file readn: self ;m :m READALL: { fcb -- } \ Reads all the given file into SELF. 0 fcb moveto: file OK? fcb readRest: self ;m :m READTOP: \ Reads all of TOPFILE into SELF, then closes and \ drops TOPFILE. TOPFILE must already be open. topfile readAll: self close: topfile OK? drop: loadfile ;m :m $WRITE: { fcb -- } get: self fcb write: file OK? ;m :m SEND: { fcb -- } ^base 4+ 12 fcb write: file OK? all: self fcb write: file OK? ;m :m BRING: { fcb -- } ^base 4+ 12 fcb read: file OK? ?new: self size: self ^base setsize: handle all: self fcb read: file OK? ;m :m DRAW: { tRect just -- } \ Draws the string justified in rect tRect. get: self tRect just makeint call textBox ;m :m PRINTALL: { \ svPos svLim svCurs 1st? -- } nil?: self IF Nopen EXIT THEN get: pos -> svPos get: lim -> svLim curs -> svCurs -curs begin: self true -> 1st? BEGIN nextline?: self WHILE get: self type 1st? if false -> 1st? else cr 0 -> out then REPEAT svPos put: pos svLim put: lim svCurs -> curs ;m ;class